home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / MacGofer 0.22d / MacGofer Sources / compiler.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-03-17  |  41.5 KB  |  1,188 lines  |  [TEXT/MPS ]
  1. /* --------------------------------------------------------------------------
  2.  * compiler.c:  Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *              Gofer version 2.28 January 1993
  5.  *
  6.  * This is the Gofer compiler, handling translation of typechecked code to
  7.  * `kernel' language, elimination of pattern matching and translation to
  8.  * super combinators (lambda lifting).
  9.  * ------------------------------------------------------------------------*/
  10.  
  11. #include "prelude.h"
  12. #include "storage.h"
  13. #include "connect.h"
  14.  
  15. #if MPW
  16. #pragma segment Compiler
  17. #endif
  18.  
  19. Bool useConformality = TRUE;        /* TRUE => check pat-bind conform'y*/
  20.  
  21. Addr inputCode;                /* Addr of compiled code for expr  */
  22.  
  23. Name nameResult, nameBind;        /* for translating monad comps       */
  24. Name nameZero;                /* for monads with a zero       */
  25.  
  26. /* --------------------------------------------------------------------------
  27.  * Local function prototypes:
  28.  * ------------------------------------------------------------------------*/
  29.  
  30. static Cell local translate        Args((Cell));
  31. static Void local transPair        Args((Pair));
  32. static Void local transTriple        Args((Triple));
  33. static Void local transAlt        Args((Cell));
  34. static Void local transCase        Args((Cell));
  35. static List local transBinds        Args((List));
  36. static Cell local transRhs        Args((Cell));
  37. static Cell local mkConsList        Args((List));
  38. static Cell local expandLetrec        Args((Cell));
  39.  
  40. static Cell local transComp        Args((Cell,List,Cell));
  41. static Cell local transMComp        Args((Cell,Cell,Cell,List));
  42.  
  43. static Cell local refutePat        Args((Cell));
  44. static List local remPat        Args((Cell,Cell,List));
  45. static List local remPat1        Args((Cell,Cell,List));
  46.  
  47. static Cell local pmcTerm        Args((Int,List,Cell));
  48. static Cell local pmcPair        Args((Int,List,Pair));
  49. static Cell local pmcTriple        Args((Int,List,Triple));
  50. static Cell local pmcVar        Args((List,Text));
  51. static Void local pmcLetrec        Args((Int,List,Pair));
  52. static Cell local pmcVarDef        Args((Int,List,List));
  53. static Void local pmcFunDef        Args((Int,List,Triple));
  54.  
  55. static Cell local match         Args((Int,List,List));
  56. static Void local tidyHdPat        Args((Offset,Cell));
  57. static Cell local hdDiscr        Args((List));
  58. static Int  local discrKind        Args((Cell));
  59.  
  60. static Cell local matchVar        Args((Int,List,List,Cell));
  61.  
  62. static Cell local matchCon        Args((Int,List,List,Cell));
  63. static List local addConTable        Args((Cell,Cell,List));
  64. static Cell local makeCases        Args((Int,List,List));
  65.  
  66. static Cell local matchInt        Args((Int,List,List,Cell));
  67.  
  68. static List local addOffsets        Args((Int,Int,List));
  69. static Cell local mkSwitch        Args((List,Pair));
  70. static Cell local joinSw        Args((Int,List));
  71. static Bool local canFail        Args((Cell));
  72.  
  73. static Cell local lift            Args((Int,List,Cell));
  74. static Void local liftPair        Args((Int,List,Pair));
  75. static Void local liftTriple        Args((Int,List,Triple));
  76. static Void local liftAlt        Args((Int,List,Cell));
  77. static Cell local liftVar        Args((List,Cell));
  78. static Cell local liftLetrec        Args((Int,List,Cell));
  79. static Void local liftFundef        Args((Int,List,Triple));
  80. static Void local solve         Args((List));
  81.  
  82. static Cell local preComp        Args((Cell));
  83. static Cell local preCompPair        Args((Pair));
  84. static Cell local preCompTriple     Args((Triple));
  85. static Void local preCompCase        Args((Pair));
  86. static Cell local preCompOffset     Args((Int));
  87.  
  88. static Void local compileGlobalFunction Args((Pair));
  89. static Void local compileMemberFunction Args((Name));
  90. static Void local newGlobalFunction    Args((Name,Int,List,Int,Cell));
  91.  
  92. /* --------------------------------------------------------------------------
  93.  * Transformation: Convert input expressions into a less complex language
  94.  *           of terms using only LETREC, AP, constants and vars.
  95.  *           Also remove pattern definitions on lhs of eqns.
  96.  * ------------------------------------------------------------------------*/
  97.  
  98. static Cell local translate(e)           /* Translate expression:        */
  99. Cell e; {
  100.     switch (whatIs(e)) {
  101.     case LETREC    : snd(snd(e)) = translate(snd(snd(e)));
  102.               return expandLetrec(e);
  103.  
  104.     case COND    : transTriple(snd(e));
  105.               break;
  106.  
  107.     case AP     : transPair(e);
  108.               break;
  109.  
  110.     case UNIT    :
  111.     case TUPLE    :
  112.     case NAME    :
  113.     case SELECT    :
  114.     case VAROPCELL    :
  115.     case VARIDCELL    :
  116.     case DICTVAR    :
  117.     case DICTCELL    :
  118.     case INTCELL    :
  119.     case FLOATCELL  :
  120.     case STRCELL    :
  121.     case CHARCELL    : break;
  122.  
  123.     case FINLIST    : mapOver(translate,snd(e));
  124.               return mkConsList(snd(e));
  125.  
  126.     case LISTCOMP    : return transComp(translate(fst(snd(e))),
  127.                        snd(snd(e)),
  128.                        nameNil);
  129.  
  130.     case MONADCOMP  : if (dictOf(fst(fst(snd(e)))) == listMonadDict())
  131.                   return transComp(translate(fst(snd(snd(e)))),
  132.                            snd(snd(snd(e))),
  133.                            nameNil);
  134.               else
  135.                   return transMComp(fst(fst(snd(e))),
  136.                         snd(fst(snd(e))),
  137.                         translate(fst(snd(snd(e)))),
  138.                         snd(snd(snd(e))));
  139.  
  140.     case ESIGN    : return translate(fst(snd(e)));
  141.  
  142.     case CASE    : {   Cell nv = inventVar();
  143.                   mapProc(transCase,snd(snd(e)));
  144.                   return ap(LETREC,
  145.                     pair(singleton(pair(nv,snd(snd(e)))),
  146.                          ap(nv,translate(fst(snd(e))))));
  147.               }
  148.  
  149.     case LAMBDA    : {   Cell nv = inventVar();
  150.                   transAlt(snd(e));
  151.                   return ap(LETREC,
  152.                     pair(singleton(pair(
  153.                             nv,
  154.                             singleton(snd(e)))),
  155.                          nv));
  156.               }
  157.  
  158.     default     : internal("translate");
  159.     }
  160.     return e;
  161. }
  162.  
  163. static Void local transPair(pr)        /* Translate each component in a    */
  164. Pair pr; {                   /* pair of expressions.           */
  165.     fst(pr) = translate(fst(pr));
  166.     snd(pr) = translate(snd(pr));
  167. }
  168.  
  169. static Void local transTriple(tr)      /* Translate each component in a    */
  170. Triple tr; {                   /* triple of expressions.       */
  171.     fst3(tr) = translate(fst3(tr));
  172.     snd3(tr) = translate(snd3(tr));
  173.     thd3(tr) = translate(thd3(tr));
  174. }
  175.  
  176. static Void local transAlt(e)           /* Translate alt:           */
  177. Cell e; {                   /* ([Pat], Rhs) ==> ([Pat], Rhs')   */
  178.     snd(e) = transRhs(snd(e));
  179. }
  180.  
  181. static Void local transCase(c)           /* Translate case:           */
  182. Cell c; {                   /* (Pat, Rhs) ==> ([Pat], Rhs')       */
  183.     fst(c) = singleton(fst(c));
  184.     snd(c) = transRhs(snd(c));
  185. }
  186.  
  187. static List local transBinds(bs)       /* Translate list of bindings:       */
  188. List bs; {                   /* eliminating pattern matching on  */
  189.     List newBinds;               /* lhs of bindings.           */
  190.  
  191.     for (newBinds=NIL; nonNull(bs); bs=tl(bs)) {
  192.     if (isVar(fst(hd(bs)))) {
  193.         mapProc(transAlt,snd(hd(bs)));
  194.         newBinds = cons(hd(bs),newBinds);
  195.     }
  196.     else
  197.         newBinds = remPat(fst(snd(hd(bs))),
  198.                   snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))),
  199.                   newBinds);
  200.     }
  201.  
  202.     return newBinds;
  203. }
  204.  
  205. static Cell local transRhs(rhs)        /* Translate rhs: removing line nos */
  206. Cell rhs; {
  207.     switch (whatIs(rhs)) {
  208.     case LETREC  : snd(snd(rhs)) = transRhs(snd(snd(rhs)));
  209.                return expandLetrec(rhs);
  210.  
  211.     case GUARDED : mapOver(snd,snd(rhs));        /* discard line number */
  212.                mapProc(transPair,snd(rhs));
  213.                return rhs;
  214.  
  215.     default      : return translate(snd(rhs));  /* discard line number */
  216.     }
  217. }
  218.  
  219. static Cell local mkConsList(es)       /* Construct expression for list es */
  220. List es; {                   /* using nameNil and nameCons       */
  221.     if (isNull(es))
  222.     return nameNil;
  223.     else
  224.     return ap(ap(nameCons,hd(es)),mkConsList(tl(es)));
  225. }
  226.  
  227. static Cell local expandLetrec(root)   /* translate LETREC with list of    */
  228. Cell root; {                   /* groups of bindings (from depend. */
  229.     Cell e   = snd(snd(root));           /* analysis) to use nested LETRECs  */
  230.     List bss = fst(snd(root));
  231.     Cell temp;
  232.  
  233.     if (isNull(bss))               /* should never happen, but just in */
  234.     return e;               /* case:  LETREC [] IN e  ==>  e    */
  235.  
  236.     mapOver(transBinds,bss);           /* translate each group of bindings */
  237.  
  238.     for (temp=root; nonNull(tl(bss)); bss=tl(bss)) {
  239.     fst(snd(temp)) = hd(bss);
  240.     snd(snd(temp)) = ap(LETREC,pair(NIL,e));
  241.     temp           = snd(snd(temp));
  242.     }
  243.     fst(snd(temp)) = hd(bss);
  244.  
  245.     return root;
  246. }
  247.  
  248. /* --------------------------------------------------------------------------
  249.  * Transformation of list comprehensions is based on the description in
  250.  * `The Implementation of Functional Programming Languages':
  251.  *
  252.  * [ e | qs ] ++ L          => transComp e qs []
  253.  * transComp e []        l => e : l
  254.  * transComp e ((p<-xs):qs) l => LETREC _h []       = l
  255.  *                    _h (p:_xs) = transComp e qs (_h _xs)
  256.  *                    _h (_:_xs) = _h _xs --if p refutable.
  257.  *                 IN _h xs
  258.  * transComp e (b:qs)        l => if b then transComp e qs l else l
  259.  * transComp e (decls:qs)   l => LETREC decls IN transComp e qs l
  260.  * ------------------------------------------------------------------------*/
  261.  
  262. static Cell local transComp(e,qs,l)    /* Translate [e | qs] ++ l       */
  263. Cell e;
  264. List qs;
  265. Cell l; {
  266.     if (nonNull(qs)) {
  267.     Cell q     = hd(qs);
  268.     Cell qs1 = tl(qs);
  269.  
  270.     switch (fst(q)) {
  271.         case FROMQUAL : {    Cell ld    = NIL;
  272.                 Cell hVar  = inventVar();
  273.                 Cell xsVar = inventVar();
  274.  
  275.                 if (refutable(fst(snd(q))))
  276.                     ld = cons(pair(singleton(
  277.                             ap(ap(nameCons,
  278.                               WILDCARD),
  279.                               xsVar)),
  280.                            ap(hVar,xsVar)),
  281.                           ld);
  282.  
  283.                 ld = cons(pair(singleton(
  284.                         ap(ap(nameCons,
  285.                               fst(snd(q))),
  286.                               xsVar)),
  287.                            transComp(e,
  288.                              qs1,
  289.                              ap(hVar,xsVar))),
  290.                       ld);
  291.                 ld = cons(pair(singleton(nameNil),
  292.                            l),
  293.                       ld);
  294.  
  295.                 return ap(LETREC,
  296.                       pair(singleton(pair(hVar,
  297.                                   ld)),
  298.                            ap(hVar,
  299.                           translate(snd(snd(q))))));
  300.                 }
  301.  
  302.         case QWHERE   : return
  303.                 expandLetrec(ap(LETREC,
  304.                         pair(snd(q),
  305.                              transComp(e,qs1,l))));
  306.  
  307.         case BOOLQUAL : return ap(COND,
  308.                       triple(translate(snd(q)),
  309.                          transComp(e,qs1,l),
  310.                          l));
  311.     }
  312.     }
  313.  
  314.     return ap(ap(nameCons,e),l);
  315. }
  316.  
  317. /* --------------------------------------------------------------------------
  318.  * Transformation of monad comprehensions is based on the description in
  319.  * Comprehending monads / The essence of functional programming:
  320.  *
  321.  * [ e | ]                =>  return m e
  322.  * [ e | p <- exp, qs ]   =>  LETREC _h p = [ e | qs]
  323.  *                     _h _ = zero m0    -- if monad with 0
  324.  *                  IN bind m exp _h
  325.  * [ e | LET decls, qs ]  =>  LETREC decls IN [ e | qs ]
  326.  * [ e | guard, qs ]      =>  if guard then [ e | qs ] else zero m0
  327.  *
  328.  * where  m :: Monad f,  m0 :: Monad0 f
  329.  * ------------------------------------------------------------------------*/
  330.  
  331. static Cell local transMComp(m,m0,e,qs)    /* Translate [e | qs]           */
  332. Cell m;
  333. Cell m0;
  334. Cell e;
  335. List qs; {
  336.     if (nonNull(qs)) {
  337.     Cell q     = hd(qs);
  338.     Cell qs1 = tl(qs);
  339.  
  340.     switch (fst(q)) {
  341.         case FROMQUAL : {    Cell ld   = NIL;
  342.                 Cell hVar = inventVar();
  343.  
  344.                 if (refutable(fst(snd(q))) && nonNull(m0))
  345.                     ld = cons(pair(singleton(WILDCARD),
  346.                            ap(nameZero,m0)),ld);
  347.  
  348.                 ld = cons(pair(singleton(fst(snd(q))),
  349.                            transMComp(m,m0,e,qs1)),
  350.                       ld);
  351.  
  352.                 return ap(LETREC,
  353.                       pair(singleton(pair(hVar,ld)),
  354.                            ap(ap(ap(nameBind,
  355.                             m),
  356.                              translate(snd(snd(q)))),
  357.                           hVar)));
  358.                 }
  359.  
  360.         case QWHERE      : return
  361.                 expandLetrec(ap(LETREC,
  362.                         pair(snd(q),
  363.                              transMComp(m,m0,e,qs1))));
  364.  
  365.         case BOOLQUAL : return ap(COND,
  366.                       triple(translate(snd(q)),
  367.                          transMComp(m,m0,e,qs1),
  368.                          ap(nameZero,m0)));
  369.     }
  370.     }
  371.  
  372.     return ap(ap(nameResult,m),e);
  373. }
  374.  
  375. /* --------------------------------------------------------------------------
  376.  * Elimination of pattern bindings:
  377.  *
  378.  * The following code adopts the definition of irrefutable patterns as given
  379.  * in the Haskell report in which only variables, wildcards and ~pat patterns
  380.  * are irrefutable.  Note that the definition in Peyton Jones also includes
  381.  * product constructor functions (e.g. tuples) as irrefutable patterns.
  382.  * ------------------------------------------------------------------------*/
  383.  
  384. Bool refutable(pat)          /* is pattern refutable (do we need to   */
  385. Cell pat; {              /* to use a conformality check?)       */
  386.     Cell c = getHead(pat);
  387.  
  388.     switch (whatIs(c)) {
  389.     case ASPAT     : return refutable(snd(snd(pat)));
  390.  
  391.     case LAZYPAT   :
  392.     case VAROPCELL :
  393.     case VARIDCELL :
  394.     case DICTVAR   :
  395.     case WILDCARD  : return FALSE;
  396.  
  397.     default        : return TRUE;
  398.     }
  399. }
  400.  
  401. static Cell local refutePat(pat)  /* find pattern to refute in conformality*/
  402. Cell pat; {              /* test with pat.               */
  403.                   /* e.g. refPat  (x,y) == (_,_)       */
  404.                   /*      refPat ~(x,y) == _      etc..    */
  405.  
  406.     switch (whatIs(pat)) {
  407.     case ASPAT     : return refutePat(snd(snd(pat)));
  408.  
  409.     case FINLIST   : {   Cell ys = snd(pat);
  410.                  Cell xs = NIL;
  411.                  for (; nonNull(ys); ys=tl(ys))
  412.                  xs = ap(ap(nameCons,refutePat(hd(ys))),xs);
  413.                  return revOnto(xs,nameNil);
  414.              }
  415.  
  416.     case VAROPCELL :
  417.     case VARIDCELL :
  418.     case DICTVAR   :
  419.     case WILDCARD  :
  420.     case LAZYPAT   : return WILDCARD;
  421.  
  422.     case INTCELL   :
  423.         case FLOATCELL :
  424.     case STRCELL   :
  425.     case CHARCELL  :
  426.     case ADDPAT    :
  427.     case MULPAT    :
  428.     case UNIT      :
  429.     case TUPLE     :
  430.     case NAME      : return pat;
  431.  
  432.     case AP        : return ap(refutePat(fun(pat)),refutePat(arg(pat)));
  433.  
  434.     default        : internal("refutePat");
  435.              return NIL; /*NOTREACHED*/
  436.     }
  437. }
  438.  
  439. #define addEqn(v,val,lds)  cons(pair(v,singleton(pair(NIL,val))),lds)
  440.  
  441. static List local remPat(pat,expr,lds)
  442. Cell pat;              /* Produce list of definitions for eqn   */
  443. Cell expr;              /* pat = expr, including a conformality  */
  444. List lds; {              /* check if required.            */
  445.  
  446.     /* Conformality test (if required):
  447.      *     pat = expr  ==>    nv = LETREC confCheck nv@pat = nv
  448.      *                 IN confCheck expr
  449.      *                remPat1(pat,nv,.....);
  450.      */
  451.  
  452.     if (useConformality && refutable(pat)) {
  453.     Cell confVar = inventVar();
  454.     Cell nv      = inventVar();
  455.     Cell locfun  = pair(confVar,         /* confVar [([nv@refPat],nv)] */
  456.                 singleton(pair(singleton(ap(ASPAT,
  457.                             pair(nv,
  458.                                  refutePat(pat)))),
  459.                        nv)));
  460.  
  461.     if (whatIs(expr)==GUARDED) {         /* A spanner ... special case */
  462.         lds  = addEqn(nv,expr,lds);         /* for guarded pattern binding*/
  463.         expr = nv;
  464.         nv   = inventVar();
  465.     }
  466.  
  467.     if (whatIs(pat)==ASPAT) {         /* avoid using new variable if*/
  468.         nv   = fst(snd(pat));         /* a variable is already given*/
  469.         pat  = snd(snd(pat));         /* by an as-pattern       */
  470.     }
  471.  
  472.     lds = addEqn(nv,                /* nv =        */
  473.              ap(LETREC,pair(singleton(locfun),    /* LETREC [locfun] */
  474.                     ap(confVar,expr))), /* IN confVar expr */
  475.              lds);
  476.  
  477.     return remPat1(pat,nv,lds);
  478.     }
  479.  
  480.     return remPat1(pat,expr,lds);
  481. }
  482.  
  483. static List local remPat1(pat,expr,lds)
  484. Cell pat;              /* Add definitions for: pat = expr to    */
  485. Cell expr;              /* list of local definitions in lds.       */
  486. List lds; {
  487.     Cell c;
  488.  
  489.     switch (whatIs(c=getHead(pat))) {
  490.     case WILDCARD  :
  491.     case UNIT      :
  492.     case INTCELL   :
  493.         case FLOATCELL :
  494.     case STRCELL   :
  495.     case CHARCELL  : break;
  496.  
  497.     case ASPAT     : return remPat1(snd(snd(pat)),       /* v@pat = expr */
  498.                     fst(snd(pat)),
  499.                     addEqn(fst(snd(pat)),expr,lds));
  500.  
  501.     case LAZYPAT   : {   Cell nv;
  502.  
  503.                  if (isVar(expr) || isName(expr))
  504.                  nv  = expr;
  505.                  else {
  506.                  nv  = inventVar();
  507.                  lds = addEqn(nv,expr,lds);
  508.                  }
  509.  
  510.                  return remPat(snd(pat),nv,lds);
  511.              }
  512.  
  513.     case ADDPAT    : return addEqn(snd(pat),       /* n + k = expr */
  514.                        ap(ap(nameMinus,expr),
  515.                       mkInt(intValOf(fst(pat)))),
  516.                        lds);
  517.  
  518.     case MULPAT    : return addEqn(snd(pat),       /* c * n = expr */
  519.                        ap(ap(nameDivide,expr),
  520.                       mkInt(intValOf(fst(pat)))),
  521.                        lds);
  522.  
  523.     case FINLIST   : return remPat1(mkConsList(snd(pat)),expr,lds);
  524.  
  525.     case DICTVAR   : /* shouldn't really occur */
  526.     case VARIDCELL :
  527.     case VAROPCELL : return addEqn(pat,expr,lds);
  528.  
  529.     case TUPLE     :
  530.     case NAME      : {   List ps = getArgs(pat);
  531.  
  532.                  if (nonNull(ps)) {
  533.                  Cell nv, sel;
  534.                  Int  i;
  535.  
  536.                  if (isVar(expr) || isName(expr))
  537.                      nv  = expr;
  538.                  else {
  539.                      nv  = inventVar();
  540.                      lds = addEqn(nv,expr,lds);
  541.                  }
  542.  
  543.                  sel = ap(ap(nameSel,c),nv);
  544.                  for (i=1; nonNull(ps); ++i, ps=tl(ps))
  545.                       lds = remPat1(hd(ps),
  546.                             ap(sel,mkInt(i)),
  547.                             lds);
  548.                  }
  549.              }
  550.              break;
  551.  
  552.     default        : internal("remPat1");
  553.              break;
  554.     }
  555.     return lds;
  556. }
  557.  
  558. /* --------------------------------------------------------------------------
  559.  * Eliminate pattern matching in function definitions -- pattern matching
  560.  * compiler:
  561.  *
  562.  * Based on Wadler's algorithms described in `Implementation of functional
  563.  * programming languages'.
  564.  *
  565.  * During the translation, in preparation for later stages of compilation,
  566.  * all local and bound variables are replaced by suitable offsets, and
  567.  * locally defined function symbols are given new names (which will
  568.  * eventually be their names when lifted to make top level definitions).
  569.  * ------------------------------------------------------------------------*/
  570.  
  571. static Offset freeBegin; /* only variables with offset <= freeBegin are of */
  572. static List   freeVars;  /* interest as `free' variables           */
  573. static List   freeFuns;  /* List of `free' local functions           */
  574.  
  575. static Cell local pmcTerm(co,sc,e)     /* apply pattern matching compiler  */
  576. Int  co;                   /* co = current offset           */
  577. List sc;                   /* sc = scope               */
  578. Cell e;  {                   /* e  = expr to transform       */
  579.     switch (whatIs(e)) {
  580.     case GUARDED  : map2Over(pmcPair,co,sc,snd(e));
  581.             break;
  582.  
  583.     case LETREC   : pmcLetrec(co,sc,snd(e));
  584.             break;
  585.  
  586.     case VARIDCELL:
  587.     case VAROPCELL:
  588.     case DICTVAR  : return pmcVar(sc,textOf(e));    if (!cellIsMember(hd(xs),saveFreeFuns))
  589.         saveFreeFuns = cons(hd(xs),saveFreeFuns);
  590.  
  591.     freeBegin = saveFreeBegin;
  592.     freeVars  = saveFreeVars;
  593.     freeFuns  = saveFreeFuns;
  594. }
  595.  
  596. /* --------------------------------------------------------------------------
  597.  * Main part of pattern matching compiler: convert lists of Alt to case
  598.  * construct:
  599.  *
  600.  * At each stage, each branch is represented by an element of type:
  601.  *    Switch ::= ([Pat],Scope,Rhs)
  602.  * which indicates that, if we can succeed in matching the given list of
  603.  * patterns, then the result will be the indicated Rhs.  The Scope component
  604.  * has type:
  605.  *    Scope  ::= [(Var,Expr)]
  606.  * and provides a mapping from variable names to offsets used in the matching
  607.  * process.
  608.  *
  609.  * ------------------------------------------------------------------------*/
  610.  
  611. #define switchPats(s)          fst3(s)
  612. #define switchSyms(s)          snd3(s)
  613. #define switchRhs(s)          thd3(s)
  614. #define addSym(v,o,s)          switchSyms(s) = cons(pair(v,o),switchSyms(s))
  615. #define matchMore(sw,c,co,us) nonNull(sw)?ap(FATBAR,pair(c,match(co,sw,us))):c
  616.  
  617.                        /* There are three kinds of case:   */
  618. #define CONDISCR          0        /* Constructor               */
  619. #define INTDISCR          1        /* Integer (integer const/n+k)       */
  620. #define VARDISCR          2        /* variable (or wildcard)       */
  621.  
  622. #define isConPat(discr)       (discrKind(discr)==CONDISCR)
  623. #define isVarPat(discr)       (discrKind(discr)==VARDISCR)
  624. #define isIntPat(discr)       (discrKind(discr)==INTDISCR)
  625.  
  626. static Cell local match(co,sws,us)     /* produce case statement to select */
  627. Int  co;                   /* between switches in sw, matching */
  628. List sws;                   /* pats against values at offsets   */
  629. List us; {                   /* given by us.    co is the current  */
  630.     if (nonNull(us)) {               /* offset at which new values are   */
  631.     Cell discr;               /* saved                */
  632.  
  633.     map1Proc(tidyHdPat,hd(us),sws);
  634.     switch (discrKind(discr=hdDiscr(sws))) {
  635.         case CONDISCR : return matchCon(co,sws,us,discr);
  636.         case INTDISCR : return matchInt(co,sws,us,discr);
  637.         case VARDISCR : return matchVar(co,sws,us,discr);
  638.     }
  639.     }
  640.     return joinSw(co,sws);
  641. }
  642.  
  643. static Void local tidyHdPat(u,s)       /* tidy head of pat list in a switch*/
  644. Offset u;                   /* (Principally eliminating @ pats) */
  645. Cell   s; {
  646.     Cell p = hd(switchPats(s));
  647.  
  648. thp:switch (whatIs(p)) {
  649.     case ASPAT   : addSym(fst(snd(p)),u,s);
  650.                p = snd(snd(p));
  651.                goto thp;
  652.  
  653.     case LAZYPAT : {   Cell nv    = inventVar();
  654.                switchRhs(s) = ap(LETREC,
  655.                          pair(remPat(snd(p),nv,NIL),
  656.                           switchRhs(s)));
  657.                p        = nv;
  658.                }
  659.                break;
  660.  
  661.     case FINLIST : p = mkConsList(snd(p));
  662.                break;
  663.  
  664.     case STRCELL : {   Text t = textOf(p);
  665.                Int  c;
  666.                p = NIL;
  667.                while ((c=textToStr(t++)[0])!='\0') {
  668.                    if (c=='\\' && (c=textToStr(t++)[0])!='\\')
  669.                    c = 0;
  670.                    p = ap(consChar(c),p);
  671.                }
  672.                p = revOnto(p,nameNil);
  673.                }
  674.                break;
  675.  
  676.     }
  677.     hd(switchPats(s)) = p;
  678. }
  679.  
  680. static Cell local hdDiscr(sws)           /* get discriminant of head pattern */
  681. List sws; {                   /* in first branch of a [Switch].   */
  682.     return getHead(hd(fst3(hd(sws))));
  683. }
  684.  
  685. static Int local discrKind(e)           /* find kind of discriminant       */
  686. Cell e; {
  687.     switch (whatIs(e)) {
  688.     case NAME      :
  689.     case TUPLE     :
  690.     case UNIT      :
  691.     case STRCELL   : /* shouldn't be here? */
  692.     case CHARCELL  : return CONDISCR;
  693.  
  694.     case INTCELL   :
  695.     case ADDPAT    :
  696.     case MULPAT    : return INTDISCR;
  697.  
  698.     case VARIDCELL :
  699.     case VAROPCELL :
  700.     case DICTVAR   :
  701.     case WILDCARD  : return VARDISCR;
  702.     }
  703.     internal("discrKind");
  704.     return 0;/*NOTREACHED*/
  705. }
  706.  
  707. Int discrArity(e)               /* find arity of discriminant       */
  708. Cell e; {
  709.     switch (whatIs(e)) {
  710.     case NAME      : return name(e).arity;
  711.  
  712.     case TUPLE     : return tupleOf(e);
  713.  
  714.     case UNIT      :
  715.     case STRCELL   : /* shouldn't be here? */
  716.         case FLOATCELL :
  717.     case CHARCELL  :
  718.     case INTCELL   : return 0;
  719.  
  720.     case ADDPAT    :
  721.     case MULPAT    :
  722.     case VARIDCELL :
  723.     case VAROPCELL :
  724.     case DICTVAR   :
  725.     case WILDCARD  : return 1;
  726.     }
  727.     internal("discrArity");
  728.     return 0;/*l joinSw(co,sws)       /* Combine list of Switches into rhs*/
  729. Int  co;                   /* using FATBARs as necessary       */
  730. List sws; {                   /* :: [ ([], Scope, Rhs) ]       */
  731.     Cell s = hd(sws);
  732.  
  733.     if (nonNull(tl(sws)) && canFail(thd3(s)))
  734.     return ap(FATBAR,
  735.           pair(pmcTerm(co,snd3(s),thd3(s)),
  736.                joinSw(co,tl(sws))));
  737.     return pmcTerm(co,snd3(s),thd3(s));
  738. }
  739.  
  740. static Bool local canFail(rhs)           /* Determine if expression (as rhs) */
  741. Cell rhs; {                   /* might ever be able to fail       */
  742.     switch (whatIs(rhs)) {
  743.     case LETREC  : return canFail(snd(snd(rhs)));
  744.     case GUARDED : return TRUE;    /* could get more sophisticated ..? */
  745.     default      : return FALSE;
  746.     }
  747. }
  748.  
  749. /* --------------------------------------------------------------------------
  750.  * Lambda Lifter:    replace local function definitions with new global
  751.  *             functions.  Based on Johnsson's algorithm.
  752.  * ------------------------------------------------------------------------*/
  753.  
  754. static Cell local lift(co,tr,e)        /* lambda lift term           */
  755. Int  co;
  756. List tr;
  757. Cell e; {
  758.     switch (whatIs(e)) {
  759.     case GUARDED   : map2Proc(liftPair,co,tr,snd(e));
  760.              break;
  761.  
  762.     case FATBAR    : liftPair(co,tr,snd(e));
  763.              break;
  764.  
  765.     case CASE      : map2Proc(liftAlt,co,tr,snd(snd(e)));
  766.              break;
  767.  
  768.     case COND      : liftTriple(co,tr,snd(e));
  769.              break;
  770.  
  771.     case AP        : liftPair(co,tr,e);
  772.              break;
  773.  
  774.     case VAROPCELL :
  775.     case VARIDCELL :
  776.     case DICTVAR   : return liftVar(tr,e);
  777.  
  778.     case LETREC    : return liftLetrec(co,tr,e);
  779.  
  780.     case UNIT      :
  781.     case TUPLE     :
  782.     case NAME      :
  783.     case SELECT    :
  784.     case DICTCELL  :
  785.     case INTCELL   :
  786.     case FLOATCELL :
  787.     case STRCELL   :
  788.     case OFFSET    :
  789.     case CHARCELL  : break;
  790.  
  791.     default        : internal("lift");
  792.              break;
  793.     }
  794.     return e;
  795. }
  796.  
  797. static Void local liftPair(co,tr,pr)   /* lift pair of terms           */
  798. Int  co;
  799. List tr;
  800. Pair pr; {
  801.     fst(pr) = lift(co,tr,fst(pr));
  802.     snd(pr) = lift(co,tr,snd(pr));
  803. }
  804.  
  805. static Void local liftTriple(co,tr,e)  /* lift triple of terms           */
  806. Int    co;
  807. List   tr;
  808. Triple e; {
  809.     fst3(e) = lift(co,tr,fst3(e));
  810.     snd3(e) = lift(co,tr,snd3(e));
  811.     thd3(e) = lift(co,tr,thd3(e));
  812. }
  813.  
  814. static Void local liftAlt(co,tr,pr)    /* lift (discr,case) pair       */
  815. Int  co;
  816. List tr;
  817. Cell pr; {                   /* pr :: (discr,case)           */
  818.     snd(pr) = lift(co+discrArity(fst(pr)), tr, snd(pr));
  819. }
  820.  
  821. static Cell local liftVar(tr,e)        /* lift variable            */
  822. List tr;
  823. Cell e; {
  824.     Text t = textOf(e);
  825.  
  826.     while (nonNull(tr) && textOf(fst(hd(tr)))!=t)
  827.     tr = tl(tr);
  828.     if (isNull(tr))
  829.     internal("liftVar");
  830.     return snd(hd(tr));
  831. }
  832.  
  833. static Cell local liftLetrec(co,tr,e)  /* lift letrec term           */
  834. Int  co;
  835. List tr;
  836. Cell e; {
  837.     List vs = fst(fst(snd(e)));
  838.     List fs = snd(fst(snd(e)));
  839.     List fds;
  840.  
  841.     co += length(vs);
  842.     solve(fs);
  843.  
  844.     for (fds=fs; nonNull(fds); fds=tl(fds)) {
  845.     Triple fundef = hd(fds);
  846.     List   fvs    = fst3(thd3(fundef));
  847.     Cell   n      = newName(textOf(fst3(fundef)));
  848.     Cell   e0;
  849.  
  850.     for (e0=n; nonNull(fvs); fvs=tl(fvs))
  851.         e0 = ap(e0,hd(fvs));
  852.  
  853.     tr         = cons(pair(fst3(fundef),e0),tr);
  854.     fst3(fundef) = n;
  855.     }
  856.  
  857.     map2Proc(liftFundef,co,tr,fs);
  858.     if (isNull(vs))
  859.     return lift(co,tr,snd(snd(e)));
  860.     map2Over(lift,co,tr,vs);
  861.     fst(snd(e)) = vs;
  862.     snd(snd(e)) = lift(co,tr,snd(snd(e)));
  863.     return e;
  864. }
  865.  
  866. static Void local liftFundef(co,tr,fd) /* lift function definition       */
  867. Int    co;
  868. List   tr;
  869. Triple fd; {
  870.     Int arity = intOf(snd3(fd));
  871.     newGlobalFunction(fst3(fd),              /* name       */
  872.               arity,                 /* arity       */
  873.               fst3(thd3(fd)),             /* free variables */
  874.               co+arity,              /* current offset */
  875.               lift(co+arity,tr,thd3(thd3(fd)))); /* lifted case    */
  876. }
  877.  
  878. /* Each element in a list of fundefs has the form: (v,a,(fvs,ffs,rhs))
  879.  * where fvs is a list of free variables which must be added as extra
  880.  *         parameters to the lifted version of function v,
  881.  *     ffs is a list of fundefs defined either in the group of definitions
  882.  *         including v, or in some outer LETREC binding.
  883.  *
  884.  * In order to determine the correct value for fvs, we must include:
  885.  * - all variables explicitly appearing in the body rhs (this much is
  886.  *   achieved in pmcVar).
  887.  * - all variables required for lifting those functions appearing in ffs.
  888.  *   - If f is a fundef in an enclosing group of definitions then the
  889.  *     correct list of variables to include with each occurrence of f will
  890.  *     have already been calculated and stored in the fundef f.  We simply
  891.  *     take the union of this list with fvs.
  892.  *   - If f is a fundef in the same group of bindings as v, then we iterate
  893.  *     to find the required solution.
  894.  */
  895.  
  896. #ifdef DEBUG_CODE
  897. static Void dumpFundefs(fs)
  898. List fs; {
  899.     printf("Dumping Fundefs:\n");
  900.     for (; nonNull(fs); fs=tl(fs)) {
  901.         Cell t   = hd(fs);
  902.     List fvs = fst3(thd3(t));
  903.     List ffs = snd3(thd3(t));
  904.     printf("Var \"%s\", arity %d:\n",textToStr(textOf(fst3(t))),
  905.                                          intOf(snd3(t)));
  906.     printf("Free variables: ");
  907.         printExp(stdout,fvs);
  908.     putchar('\n');
  909.     printf("Local functions: ");
  910.         for (; nonNull(ffs); ffs=tl(ffs)) {
  911.         printExp(stdout,fst3(hd(ffs)));
  912.         printf("  ");
  913.     }
  914.     putchar('\n');
  915.     }
  916.     printf("----------------\n");
  917. }
  918. #endif
  919.  
  920. static Void local solve(fs)           /* Solve eqns for lambda-lifting    */
  921. List fs; {                   /* of local function definitions    */
  922.     Bool hasChanged;
  923.     List fs0, fs1;
  924.  
  925.     /* initial pass distinguishes between those functions defined in fs and
  926.      * those defined in enclosing LETREC clauses ...
  927.      */
  928.  
  929.     for (fs0=fs; nonNull(fs0); fs0=tl(fs0)) {
  930.     List fvs = fst3(thd3(hd(fs0)));
  931.     List ffs = NIL;
  932.  
  933.     for (fs1=snd3(thd3(hd(fs0))); nonNull(fs1); fs1=tl(fs1)) {
  934.         if (cellIsMember(hd(fs1),fs))     /* function in same LETREC*/
  935.         ffs = cons(hd(fs1),ffs);
  936.         else {                 /* enclosing letrec       */
  937.         List fvs1 = fst3(thd3(hd(fs1)));
  938.         for (; nonNull(fvs1); fvs1=tl(fvs1))
  939.             if (!cellIsMember(hd(fvs1),fvs))
  940.             fvs = cons(hd(fvs1),fvs);
  941.         }
  942.     }
  943.     fst3(thd3(hd(fs0))) = fvs;
  944.     snd3(thd3(hd(fs0))) = ffs;
  945.     }
  946.  
  947.     /* now that the ffs component of each fundef in fs has been restricted
  948.      * to a list of fundefs in fs, we iterate to add any extra free variables
  949.      * that are needed (in effect, calculating the reflexive transitive
  950.      * closure of the local call graph of fs).
  951.      */
  952.  
  953.     do {
  954.     hasChanged = FALSE;
  955.     for (fs0=fs; nonNull(fs0); fs0=tl(fs0)) {
  956.         List fvs0 = fst3(thd3(hd(fs0)));
  957.         for (fs1=snd3(thd3(hd(fs0))); nonNull(fs1); fs1=tl(fs1))
  958.          if (hd(fs1)!=hd(fs0)) {
  959.              List fvs1 = fst3(thd3(hd(fs1)));
  960.              for (; nonNull(fvs1); fvs1=tl(fvs1))
  961.              if (!cellIsMember(hd(fvs1),fvs0)) {
  962.                  hasChanged = TRUE;
  963.                  fvs0    = cons(hd(fvs1),fvs0);
  964.              }
  965.         }
  966.         if (hasChanged) fst3(thd3(hd(fs0))) = fvs0;
  967.     }
  968.     } while (hasChanged);
  969. }
  970.  
  971. /* --------------------------------------------------------------------------
  972.  * Pre-compiler: Uses output from lambda lifter to produce terms suitable
  973.  *         for input to code generator.
  974.  * ------------------------------------------------------------------------*/
  975.  
  976. static List extraVars;       /* List of additional vars to add to function   */
  977. static Int  numExtraVars;  /* Length of extraVars               */
  978. static Int  localOffset;   /* offset value used in original definition       */
  979. static Int  localArity;    /* arity of function being compiled w/o extras  */
  980.  
  981. /* --------------------------------------------------------------------------
  982.  * Arrangement of arguments on stack prior to call of
  983.  *           n x_1 ... x_e y_1 ... y_a
  984.  * where
  985.  *    e = numExtraVars,      x_1,...,x_e are the extra params to n
  986.  *    a = localArity of n,   y_1,...,y_a are the original params
  987.  *
  988.  *    offset 1       :  y_a  }                   STACKPART1
  989.  *    ..           }
  990.  *    offset a       :  y_1  }
  991.  *
  992.  *    offset 1+a   :  x_e  }                   STACKPART2
  993.  *    ..           }
  994.  *    offset e+a   :  x_1  }
  995.  *
  996.  *    offset e+a+1 :  used for temporary results ...   STACKPART3
  997.  *    ..
  998.  *    ..
  999.  *
  1000.  * In the original defn for n, the offsets in STACKPART1 and STACKPART3
  1001.  * are contiguous.  To add the extra parameters we need to insert the
  1002.  * offsets in STACKPART2, adjusting offset values as necessary.
  1003.  * ------------------------------------------------------------------------*/
  1004.  
  1005. static Cell local preComp(e)           /* Adjust output from compiler to   */
  1006. Cell e; {                   /* include extra parameters       */
  1007.     switch (whatIs(e)) {
  1008.     case GUARDED   : mapOver(preCompPair,snd(e));
  1009.                  break;
  1010.  
  1011.     case LETREC    : mapOver(preComp,fst(snd(e)));
  1012.                  snd(snd(e)) = preComp(snd(snd(e)));
  1013.                  break;
  1014.  
  1015.     case COND      : return ap(COND,preCompTriple(snd(e)));
  1016.  
  1017.     case FATBAR    : return ap(FATBAR,preCompPair(snd(e)));
  1018.  
  1019.     case AP        : return preCompPair(e);
  1020.  
  1021.     case CASE      : fst(snd(e)) = preComp(fst(snd(e)));
  1022.                  mapProc(preCompCase,snd(snd(e)));
  1023.                  break;
  1024.  
  1025.     case OFFSET    : return preCompOffset(offsetOf(e));
  1026.  
  1027.     case UNIT      :
  1028.     case TUPLE     :
  1029.     case NAME      :
  1030.     case SELECT    :
  1031.     case DICTCELL  :
  1032.     case INTCELL   :
  1033.     case FLOATCELL :
  1034.     case STRCELL   :
  1035.     case CHARCELL  : break;
  1036.  
  1037.     default        : internal("preComp");
  1038.     }
  1039.     return e;
  1040. }
  1041.  
  1042. static Cell local preCompPair(e)       /* Apply preComp to pair of Exprs   */
  1043. Pair e; {
  1044.     return pair(preComp(fst(e)),
  1045.         preComp(snd(e)));
  1046. }
  1047.  
  1048. static Cell local preCompTriple(e)     /* Apply preComp to triple of Exprs */
  1049. Triple e; {
  1050.     return triple(preComp(fst3(e)),
  1051.           preComp(snd3(e)),
  1052.           preComp(thd3(e)));
  1053. }
  1054.  
  1055. static Void local preCompCase(e)       /* Apply preComp to (Discr,Expr)    */
  1056. Pair e; {
  1057.     snd(e) = preComp(snd(e));
  1058. }
  1059.  
  1060. static Cell local preCompOffset(n)     /* Determine correct offset value   */
  1061. Int n; {                   /* for local variable/function arg. */
  1062.     if (n>localOffset-localArity)
  1063.     if (n>localOffset)                     /* STACKPART3 */
  1064.         return mkOffset(n-localOffset+localArity+numExtraVars);
  1065.     else                             /* STACKPART1 */
  1066.         return mkOffset(n-localOffset+localArity);
  1067.     else {                             /* STACKPART2 */
  1068.     List fvs = extraVars;
  1069.     Int  i     = localArity+numExtraVars;
  1070.  
  1071.     for (; nonNull(fvs) && offsetOf(hd(fvs))!=n; --i)
  1072.         fvs=tl(fvs);
  1073.     return mkOffset(i);
  1074.     }
  1075. }
  1076.  
  1077. /* --------------------------------------------------------------------------
  1078.  * Main entry points to compiler:
  1079.  * ------------------------------------------------------------------------*/
  1080.  
  1081. Void compileExp() {               /* compile input expression       */
  1082.     compiler(RESET);
  1083.  
  1084.     inputExpr     = lift(0,NIL,pmcTerm(0,NIL,translate(inputExpr)));
  1085.     extraVars     = NIL;
  1086.     numExtraVars = 0;
  1087.     localOffset  = 0;
  1088.     localArity     = 0;
  1089.     inputCode     = codeGen(NIL,0,preComp(inputExpr));
  1090.     inputExpr     = NIL;
  1091. }
  1092.  
  1093. Void compileDefns() {               /* compile script definitions       */
  1094.     Target t = length(valDefns) + length(overDefns);
  1095.     Target i = 0;
  1096.  
  1097.     setGoal("Compiling",t);
  1098.     for (; nonNull(valDefns); valDefns=tl(valDefns)) {
  1099.     mapProc(compileGlobalFunction,transBinds(hd(valDefns)));
  1100.     soFar(i++);
  1101.     }
  1102.     for (; nonNull(overDefns); overDefns=tl(overDefns)) {
  1103.         compileMemberFunction(hd(overDefns));
  1104.     soFar(i++);
  1105.     }
  1106.     done();
  1107. }
  1108.  
  1109. static Void local compileGlobalFunction(bind)
  1110. Pair bind; {
  1111.     Name n     = findName(textOf(fst(bind)));
  1112.     List defs  = snd(bind);
  1113.     Int  arity = length(fst(hd(defs)));
  1114.  
  1115.     if (isNull(n))
  1116.     internal("compileGlobalFunction");
  1117.     compiler(RESET);
  1118.     map1Over(mkSwitch,NIL,defs);
  1119.     newGlobalFunction(n,
  1120.               arity,
  1121.               NIL,
  1122.               arity,
  1123.               lift(arity,
  1124.                NIL,
  1125.                match(arity,
  1126.                  defs,
  1127.                  addOffsets(arity,1,NIL))));
  1128. }
  1129.  
  1130. static Void local compileMemberFunction(n)
  1131. Name n; {
  1132.     List defs  = name(n).defn;
  1133.     Int  arity = length(fst(hd(defs)));
  1134.  
  1135.     compiler(RESET);
  1136.     mapProc(transAlt,defs);
  1137.     map1Over(mkSwitch,NIL,defs);
  1138.     newGlobalFunction(n,
  1139.               arity,
  1140.               NIL,
  1141.               arity,
  1142.               lift(arity,
  1143.                NIL,
  1144.                match(arity,
  1145.                  defs,
  1146.                  addOffsets(arity,1,NIL))));
  1147. }
  1148.  
  1149. static Void local newGlobalFunction(n,arity,fvs,co,e)
  1150. Name n;
  1151. Int  arity;
  1152. List fvs;
  1153. Int  co;
  1154. Cell e; {
  1155.     extraVars      = fvs;
  1156.     numExtraVars  = length(extraVars);
  1157.     localOffset   = co;
  1158.     localArity      = arity;
  1159.     name(n).arity = arity+numExtraVars;
  1160.     name(n).code  = codeGen(n,name(n).arity,preComp(e));
  1161. }
  1162.  
  1163. /* --------------------------------------------------------------------------
  1164.  * Compiler control:
  1165.  * ------------------------------------------------------------------------*/
  1166.  
  1167. Void compiler(what)
  1168. Int what; {
  1169.     switch (what) {
  1170.     case INSTALL :
  1171.     case RESET   : freeVars      = NIL;
  1172.                freeFuns      = NIL;
  1173.                freeBegin     = mkOffset(0);
  1174.                extraVars     = NIL;
  1175.                numExtraVars  = 0;
  1176.                localOffset   = 0;
  1177.                localArity    = 0;
  1178.                break;
  1179.  
  1180.     case MARK    : mark(freeVars);
  1181.                mark(freeFuns);
  1182.                mark(extraVars);
  1183.                break;
  1184.     }
  1185. }
  1186.  
  1187. /*-------------------------------------------------------------------------*/
  1188.